Shareware Super Platinum 8

home *** CD-ROM | disk | FTP | other *** search

/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / DATABASE / BORUSR2.ZIP;1 / PICKLIST.PRG < prev next >

Wrap

Text File | 1992-06-03 | 13.9 KB | 463 lines

PROCEDURE PickList *-------------------------------------------------------------------------- *-- Programmer..: Martin Leon (HMAN) (A-T) *-- Date........: 11/1990 *-- Notes.......: A "generic" PickList routine ... *-- Written for.: dBASE IV, 1.1 *-- Rev. History: Published in TechNotes, November, 1990 (DIYPOPUP) *-- Modified for dHUNG/dUFLP standards, Ken Mayer, 7/12/91 *-- Calls.......: None *-- Called by...: Any *-- Usage.......: do PickList with "<cFields>",<nULRow>,<nULCol>,<nBRRow>,; *-- <nBRCol>, "<cNormColor>","<cFieldColor>","<cBorder>" *-- Example.....: Do PickList with "First_name+' '+Last_name",5,10,15,60,; *-- "rg+/gb","gb/r","DOUBLE" *-- Returns.....: indirectly returns the record pointer of record that was *-- highlighted when <Enter> was pressed. *-- Parameters..: cFields = fields to be displayed in picklist *-- nULRow = Row coordinate of upper left corner *-- nULCol = Column coordinate of upper left corner *-- nBRRow = Row coordinate of lower right corner *-- nBRCol = Column coordinate of lower right corner *-- cNormColor = Foreground/Background of normal text *-- cFieldColor = Foreground/Background of highlighted fields *-- cBorder = NONE, SINGLE, DOUBLE (defaults to Single if *-- sent as a nul string ("") ) *-------------------------------------------------------------------------- parameter cFields, nULRow, nULCol, nBRRow, nBRCol, cNormColor, ; cFieldColor, cBorder private cCursor, cEscape, cTalk cCursor = set("CURSOR") cEscape = set("ESCAPE") cTalk = set("TALK") set cursor off set escape off set talk off cTypeCheck = type("cFields")+type("nULRow")+type("nULCol")+type("nBRRow")+ ; type("nBRCol")+type("cNormColor")+type("cFieldColor")+type("cBorder") lError = .F. do case && Check data types case cTypeCheck # "CNNNNCCC" clear @ 7,17 say "Data type mismatch -- check all parameters" lError = .T. && Check for bottom limit with STatUS ON case ((nBRRow >21 .and. set("DISPLAY") # "EGA43") ; .or. (nBRRow >39 .and. set("DISPLAY") = "EGA43")) ; .and. set("STatUS") = "ON" clear @ 7,15 say "Cannot use this popup on or below STatUS line" lError = .T. && Check for bottom limit with STatUS ofF case ((nBRRow >24 .and. set("DISPLAY") # "EGA43") ; .or. (nBRRow >42 .and. set("DISPLAY") = "EGA43")) ; .and. set("STatUS") = "ofF" clear @ 7,16 say "Bottom coordinate beyond bottom of screen" lError = .T. && Check left & right coordinates case nULCol < 0 .or. nBRCol > 79 clear @ 7,24 say "Invalid Column coordinate" lError = .T. && Check to make sure popup can display at least one record case nBRRow - nULRow < 2 clear @ 7,19 say "Popup must be at least 3 lines high" lError = .T. endcase if lError @ 5,5 to 9,70 double @ 11, 32 say "Press Any Key" nX = 0 do while nX = 0 nX = inkey() enddo set cursor &cCursor set escape &cEscape set talk &cTalk return endif && Save colors of normal and fields to restor when done cFieldset = set("ATTRIBUTES") cNormSet = left(cFieldset, at(",",cFieldset)-1) do while "," $ cFieldset cFieldset = substr(cFieldset, at(",",cFieldset)+1) enddo && If they were provided, set to colors passed on from calling program if len(cNormColor) # 0 set color of normal to &cNormColor endif if len(cFieldColor) # 0 set color of fields to &cFieldColor endif nPromptW = nBRCol - nULCol - 1 @ nULRow, nULCol clear to nBRRow, nBRCol @ nULRow, nULCol to nBRRow, nBRCol &cBorder if eof() skip -1 endif && Save current record pointer and determine record number of top record nTmpRec = recno() go top nTopRec = recno() go nTmpRec nMaxRecs = nBRRow - nULRow - 1 nKey = 0 lGoBack = .F. declare aPrompt[nMaxRecs], aRec[nMaxRecs] do while .not. lGoBack nChcNum = 1 nTopRow = nULRow + 1 nLeftCol = nULCol + 1 nRowOffset = 0 nLastCurs = 0 && This loop puts text into prompts do while nRowOffset + 1 <= nMaxRecs if .not. eof() cTemp = &cFields && Expands cFields into string expression aPrompt[nChcNum] = substr(cTemp, 1, nPromptW) && If prompt doesn't fill entire box, add spaces if len(aPrompt[nChcNum]) < nPromptW aPrompt[nChcNum] = aPrompt[nChcNum] + ; space(nPromptW - len(aPrompt[nChcNum])) endif aRec[nChcNum] = recno() @ nTopRow+nRowOffset , nLeftCol say aPrompt[nChcNum] endif nRowOffset = nRowOffset + 1 nChcNum = nChcNum + 1 skip && If last record reached, clear rest of box if eof() do while nRowOffset + 1 <= nMaxRecs @ nTopRow+nRowOffset, nLeftCol say space(nPromptW) nRowOffset = nRowOffset +1 enddo exit endif enddo nHighChc = nChcNum - 1 if nKey # 2 .and. nKey # 3 && if the last key pressed wasn't <end> nChcNum = 1 && or <PgDn> nRowOffset = 0 else nChcNum = nHighChc nRowOffset = nHighChc - 1 endif @ nTopRow+nRowOffset , nLeftCol get aPrompt[nChcNum] clear gets && This loops traps the keys do while .T. nKey = inkey() do case case nKey = 5 && Up arrow && If first record displayed is first record in database && and it is already highlighted if aRec[1] = nTopRec .and. nChcNum = 1 loop endif && If first record is highlighted but is not top record, && shift prompt contents down if aRec[1] # nTopRec .and. nChcNum = 1 go aRec[1] nX = nHighChc do while nX > 1 aRec[nX] = aRec[nX - 1] aPrompt[nX] = aPrompt[nX - 1] nX = nX - 1 enddo && Get prompt for additional record to be displayed skip -1 aRec[1] = recno() cTemp = &cFields aPrompt[1] = substr(cTemp, 1, nPromptW) if len(aPrompt[1]) < nPromptW aPrompt[1] = aPrompt[1] + ; space(nPromptW - len(aPrompt[1])) endif skip + nMaxRecs && If maximum possible records aren't displayed if nHighChc < nMaxRecs nHighChc = nHighChc + 1 skip -1 aRec[nHighChc] = recno() cTemp = &cFields aPrompt[nHighChc] = substr(cTemp, 1, nPromptW) if len(aPrompt[nHighChc]) < nPromptW aPrompt[nHighChc] = aPrompt[nHighChc] + ; space(nPromptW - len(aPrompt[nHighChc])) endif skip endif && Redisplay prompts with new contents nX = 1 do while nX < nHighChc + 1 @ nTopRow + nX - 1, nLeftCol say aPrompt[nX] nX = nX + 1 enddo nChcNum = 2 endif nChcNum = iif(nChcNum = 1, nHighChc, nChcNum - 1) nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1) nLastOne = iif(nChcNum = nHighChc, 1, nChcNum+1) nThisOne = nChcNum @ nTopRow+iif(nChcNum = nHighChc, 0, nRowOffset+1) , ; nLeftCol say aPrompt[nLastOne] @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne] clear gets case nKey = 24 && Dn arrow && If last prompt is highlighted and it is last record if eof() .and. nChcNum = nHighChc loop endif && If not at last record and bottom prompt is highlighted, && shift prompt contents up if .not. eof() .and. nChcNum = nHighChc nX = 1 do while nX < nMaxRecs aRec[nX] = aRec[nX + 1] aPrompt[nX] = aPrompt[nX + 1] nX = nX + 1 enddo && Get prompt for additional record to be displayed aRec[nMaxRecs] = recno() cTemp = &cFields aPrompt[nMaxRecs] = substr(cTemp, 1, nPromptW) if len(aPrompt[nMaxRecs]) < nPromptW aPrompt[nMaxRecs] = aPrompt[nMaxRecs] + ; space(nPromptW - len(aPrompt[nMaxRecs])) endif skip && Redisplay prompts with new contents nX = nMaxRecs do while nX > 0 @ nTopRow + nX - 1, nLeftCol say aPrompt[nX] nX = nX - 1 enddo nChcNum = nMaxRecs - 1 endif nChcNum = iif(nChcNum < nHighChc, nChcNum + 1, 1) nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1) nLastOne = iif(nChcNum = 1, nHighChc, nChcNum-1) nThisOne = nChcNum @ nTopRow+iif(nChcNum = 1, nHighChc-1, nRowOffset-1) , ; nLeftCol say aPrompt[nLastOne] @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne] clear gets case nKey = 13 && Enter key && Move record pointer and go back to calling program go aRec[nChcNum] lGoBack = .T. exit case nKey = 3 && PgDn key && If last record in .DBF is displayed but not highlighted, && move highlight to bottom and wait for next key if eof() .and. nChcNum # nHighChc @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum] @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc] clear gets nChcNum = nHighChc nRowOffset = nChcNum - 1 loop endif && If highlight is not on last record that is displayed, && move highlight to it and wait for next key if nChcNum # nHighChc @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum] @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc] clear gets nChcNum = nHighChc nRowOffset = nChcNum - 1 loop endif && Highlight is at bottom record displayed but not at eof && Move record pointer down to next "page" of records and && return to main loop if .not. eof() go aRec[1] skip + nMaxRecs lGoBack = .F. exit endif && If none of the above is true, wait for another key loop case nKey = 18 && PgUp key && If top record displayed is top of .DBF but it is && not highlighted, move highlight to it and wait for next key if aRec[1] = nTopRec .and. nChcNum # 1 @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum] @ nTopRow, nLeftCol get aPrompt[1] clear gets nChcNum = 1 nRowOffset = 0 loop endif && If highlight is not on top record displayed, move && highlight to it and wait for next key if nChcNum # 1 @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum] @ nTopRow, nLeftCol get aPrompt[1] clear gets nChcNum = 1 nRowOffset = 0 loop endif && Highlight is at top record displayed but not at top of DBF. && Move record pointer up one "page" worth of records and && return to main loop to display new prompts if aRec[1] # nTopRec go aRec[1] skip - nMaxRecs lGoBack = .F. exit endif && If none of the above is true, wait for next key loop case nKey = 27 && Esc key && Move record pointer to where it was before starting this && routine and return to calling program lAbandon = .T. lGoBack = .T. go nTmpRec exit case nKey = 26 && Home key && If already at top of DBF, wait for next key if aRec[1] = nTopRec loop else && go top and return to main loop to display new prompts go top lGoBack = .F. exit endif case nKey = 2 && End key && If last record in DBF is displayed but not highlighted, && move highlight to it and wait for next key if eof() .and. nChcNum # nHighChc @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum] @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc] clear gets nChcNum = nHighChc nRowOffset = nChcNum - 1 loop endif && If last record is not displayed, go to it and && return to main loop if .not. eof() go BOTtoM skip - (nMaxRecs - 1) lGoBack = .F. exit endif && If none of the above is true, go back and wait for next key loop case nKey = 28 && F1 key && This is just sample code for the F1 key define window TempWin from 5,4 to 14,75 activate window TempWin @ 1,3 say "Use cursor keys to choose. Press <Enter> to move record pointer" @ 2,5 say "Use <PgUp>, <PgDn>, <Home>, and <End> to see other records" @ 3,26 say "Use <Esc> to abandon" @ 5,23 say "Press Any Key to Continue" nX = 0 do while nX = 0 nX = inkey() enddo deactivate window TempWin case nKey = -1 && F2 key && This is just sample code for the F2 key save screen to sScreen nX = recno() go aRec[nChcNum] set cursor ON edit nomenu noappend nodelete next 1 * READ is better if you already have a FORMat set. set cursor off go aRec[nChcNum] cTemp = &cFields && Expands cFields into string expression aPrompt[nChcNum] = substr(cTemp, 1, nPromptW) if len(aPrompt[nChcNum]) < nPromptW aPrompt[nChcNum] = aPrompt[nChcNum] + ; space(nPromptW - len(aPrompt[nChcNum])) endif restore screen from sScreen @ nTopRow+nRowOffset, nLeftCol get aPrompt[nChcNum] clear gets if nX <= reccount() go nX else go bott skip endif endcase enddo enddo && Put colors back to what they were and set CURSOR, escape, and TALK back set color of normal to &cNormSet set color of fields to &cFieldset set cursor &cCursor set escape &cEscape set talk &cTalk RETURN *-- EOP: PickList